home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Boot / list-fns.em < prev    next >
Encoding:
Text File  |  1993-02-02  |  2.4 KB  |  120 lines
  1. (defmodule list-fns
  2.   (standard0)
  3.   ()
  4.   ;;
  5.   ;;  (union (expose  arith others ccc vectors defs
  6.   ;;          extras0 macros0  lists list-operators)    
  7.   ;;(except (null vector) (expose class-names)))
  8.  
  9.   ;; Useful function not defined EulispLISP
  10.   (defun deleq (a b)
  11.     (cond
  12.      ((null b) nil)
  13.      ((eq a (car b))
  14.       (cdr b))
  15.      (t (cons (car b) (deleq a (cdr b)))) ))
  16.  
  17.   (defun mapcdr (fn lst)
  18.     (cond ((null lst) (fn nil))
  19.       ((atom lst) (fn lst))
  20.       (t (cons (fn lst)
  21.            (mapcdr fn (cdr lst))))))
  22.  
  23.   (export mapcdr)
  24.     
  25.   
  26.   (defun mapcan (f l)
  27.     (fold (lambda (x lst)
  28.         (nconc lst (f x)))
  29.       l
  30.       nil))
  31.   
  32.   (export mapcan)
  33.  
  34. ;;  (defun map-all (fn lst)
  35. ;;    (cond ((null lst) nil)
  36. ;;          ((atom lst) lst)
  37. ;;      ((consp (car lst))
  38. ;;       (cons (map-all fn (car lst))
  39. ;;         (map-all fn (cdr lst))))
  40. ;;      (t (cons (fn (car lst))
  41. ;;           (map-all fn (cdr lst))))))
  42.  
  43.   (defun map-all (fn lst)
  44.     (if (atom lst) (fn lst)
  45.       (mapcar map-all lst)))
  46.  
  47.   (defun fold (fn lst init)
  48.     (cond ((null lst) init)
  49.       (t (fold fn (cdr lst) 
  50.            (fn (car lst) init)))))
  51.  
  52.   (defun mapvect (fn vect)
  53.     (mapvect-aux fn (vector-length vect) (make-vector (vector-length vect) nil) vect))
  54.  
  55.   ;; work in RL direction (for peversity)
  56.   (defun mapvect-aux (fn i new-v old-v)
  57.     (cond ((zerop i) new-v)
  58.       (t ((setter vector-ref) new-v (- i 1) (fn (vector-ref old-v (- i 1))))
  59.          (mapvect-aux fn (- i 1) new-v old-v))))
  60.  
  61.   (defun collect (p l)
  62.     (mapcan (lambda (x)
  63.           (if (p x) 
  64.           (list x)
  65.         nil))
  66.         l))
  67.  
  68.  (defun detect (p l)
  69.    (cond ((null l) ())
  70.      ((p (car l)))
  71.      (t (detect p (cdr l)))))
  72.  
  73.  (defun posnq (thing l)
  74.    (let ((count 0))
  75.      (detect (lambda (ob)
  76.            (if (eq ob thing)
  77.            count
  78.          (progn (setq count (+ 1 count))
  79.             nil)))
  80.          l)))
  81.  (export posnq)
  82.  
  83.  (defun nthcdr (n list)
  84.    (cond ((= n 0) list)
  85.      (t (nthcdr (- n 1) (cdr list)))))
  86.  
  87.  (defun nth (n list)
  88.    (car (nthcdr n list)))
  89.  
  90.  (export nthcdr)
  91.  (defun mk-finder ()
  92.    (let* ((table (make-table eq))
  93.       (fn (lambda (x) (table-ref table x))))
  94.      ((setter setter) fn 
  95.       (lambda (x v) 
  96.     ((setter table-ref) table x v)))
  97.      fn))
  98.  
  99.  
  100.  (defun mk-counter (n)
  101.    (let ((v n))
  102.      (lambda ()
  103.        ((lambda (a)
  104.       (setq v (+ v 1))
  105.       a)
  106.     v))))
  107.   
  108.  
  109.  (defun local-var (x)
  110.    (let ((val x))
  111.      (let ((fn (lambda () val))
  112.        (set-fn (lambda (x) (setq val x) nil)))
  113.        ((setter setter) fn set-fn)
  114.        fn)))
  115.  
  116.  (export mapvect   fold map-all deleq collect detect nth mk-finder mk-counter local-var)
  117.  
  118. ) 
  119.  
  120.